Monster Media 1996 #15/Monster Media Number 15 (Monster Media)(July 1996).ISO/netmail/rnr214.zip/GENERICF.PAS

Pascal/Delphi Source File | 1996-02-28 | 44KB | 2,200 lines

unit genericf;  {generic functions unit - not rnr-specific at all}

{

[e-mail] (960115)

Copyright 1996 Russell Schulz

this code is not in the Public Domain

permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason.  have fun.

}

{
version of this unit: 1ish
}

{$define floatingpoint}
{$undef floatingpoint}

interface

uses dos;

const
  tab=#9;
  esc=#27;
  cr=#13;
  lf=#10;
  space=' ';
  comma=',';

  alwayslegalchars: set of char=
  [
   {uppercase letters}
   'A','B','C','D','E','F','G','H','I','J','K','L','M',
   'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',

   {lowercase letters}
   'a','b','c','d','e','f','g','h','i','j','k','l','m',
   'n','o','p','q','r','s','t','u','v','w','x','y','z',

   {digits}
   '0','1','2','3','4','5','6','7','8','9',

   {some punctuation}
   '!','#','$','%','&','(',')','-','@','^','_','`','{','}','~',

   {and finally, the quote}
   ''''
  ];

  sometimeslegalchars: set of char=
  [
   {must be careful with these}
   ':','.','\'
  ];


function max(a,b: integer): integer;
function min(a,b: integer): integer;
function lmax(a,b: longint): longint;
function lmin(a,b: longint): longint;
function iifs(abool: boolean; truestring, falsestring: string): string;
function leftjustify(s: string; width: integer; c: char): string;
function rightjustify(s: string; width: integer; c: char): string;
function wordtozstring(w: word; width: integer): string;
function integertozstring(i: integer; width: integer): string;
function longtozstring(l: longint; width: integer): string;
function currenttimestring: string;
function currenttimedigits: string;
function dow: integer;
function extcdow(thedow: word): string;
function cdow: string;
function dayofmonth: integer;
function month: integer;
function extmonthname(themonth: integer): string;
function monthname: string;
function year: integer;
function dayofweek(y,m,d: word): word;
function ymdtostring(year, month, day: word): string;
function dateformatted(y,m,d: word; dateformat: string): string;
function timetostring(atime: longint): string;
function currentdatestring: string;
function getenv(s: string): string;
function numoccur(c: char; s: string): integer;
function hasany(c: char; s: string): boolean;
function hasno(c: char; s: string): boolean;
function unquote(s: string): string;
function crepl(s: string; cold, cnew: char): string;
function unslash(s: string): string;
function unbackslash(s: string): string;
function ununderscore(s: string): string;
function uncomma(s: string): string;
function srepl(s: string; sold, snew: string): string;
function srepli(s: string; sold, snew: string): string;
function sreplmulti(s: string; sold, snew: string): string;
function unspace(s: string): string;
function atow(s: string): word;
function atoi(s: string): integer;
function atol(s: string): longint;
function wtoa(w: word): string;
function itoa(i: integer): string;
function ltoa(l: longint): string;
function lowcase(c: char): char;
function upper(s: string): string;
function lower(s: string): string;
function proper(s: string): string;
function ltrim(s: string): string;
function trim(s: string): string;
function right(s: string; i: integer): string;
function getfirstw(s: string): string;
function chopfirstw(var s: string): string;
function getquoted(s: string): string;
function randomletter: char;
function randomdigit: char;
function getfromaddr(from: string): string;
function getfromname(from: string): string;
function lchop(s: string; i: integer): string;
function nore(s: string): string;
function monthstringtointeger(monthstr: string): integer;
function isalpha(c: char): boolean;
function isdigit(c: char): boolean;
function isalnum(c: char): boolean;
function isidentchar(c: char): boolean;
function islower(c: char): boolean;
function isspace(c: char): boolean;
function snatchint(var s: string): integer;
function isdev(s: string): boolean;
function illegalfn(fn: string): boolean;
function suspiciousfn(fn: string): boolean;
function highestartin(groupdir: string): longint;  {used to be word}
function getuniqfile(groupdir: string): string;
function getuniqfext(basename: string): string;
function expand(str: string): string;
function rot13(s: string): string;
function indir(filespec,dir: string): boolean;
function default(defaultstr,possiblyemptystr: string): string;
function rpos(sub: string; whole: string): integer;
function rposc(s: string; c: char): integer;
function fexists(fn: string): boolean;
function dexists(dn: string): boolean;
function getfntime(fn: string): longint;
function getfnsize(fn: string): longint;
function withbackslash(s: string): string;
function nobeep(s: string): string;
function nonastychar(s: string): string;
function gettag(tag: string; s: string): string;
function hexchar(i: integer): char;
function partialmatch(cmd, template, minimum: string): boolean;
function doserrorno: byte;
function wordwith(c:char; s: string): string;
function isasciifile(fn: string): boolean;
function nthfield(astring: string; delim: char; n: integer): string;
function isinlist(astring, alist, delim: string): boolean;
function sornos(n: integer): string;
function regexintext(aregex: string; awholetext: string): boolean;
function enclosedin(astring: string; lchar,rchar: char): boolean;
function isaleapyear(ayear: integer): boolean;
function daysinyear(ayear: integer): integer;
function daysinyearmonth(ayear: integer; amonth: integer): integer;
function dayspast1970(y,m,d: word): longint;


{$ifdef VER40}
function dosversion: word;
{$endif}

{$ifdef floatingpoint}
function ator(s: string): real;
function rtoa(r: real): string;
function rwptoa(r: real; width: integer; precision: integer): string;
function rtonicea(r: real): string;
{$endif}

implementation

function max;

begin
  if a>b then max := a else max := b;
end;

function min;

begin
  min := -max(-a,-b);
end;

function lmax;

begin
  if a>b then lmax := a else lmax := b;
end;

function lmin;

begin
  lmin := -lmax(-a,-b);
end;

function iifs;

begin
  if abool then
    iifs := truestring
  else
    iifs := falsestring;
end;

function leftjustify;

var
  result: string;

begin
  result := s;

  while length(result)<width do
    result := result+c;

  leftjustify := result;
end;

function rightjustify;

var
  result: string;

begin
  result := s;

  while length(result)<width do
    result := c+result;

  rightjustify := result;
end;

function wordtozstring;

var
  result: string;

begin
  str(w,result);

  wordtozstring := rightjustify(result,width,'0');
end;

function integertozstring;

var
  result: string;

begin
  str(i,result);

  integertozstring := rightjustify(result,width,'0');
end;

function longtozstring;

var
  result: string;

begin
  str(l,result);

  longtozstring := rightjustify(result,width,'0');
end;

function currenttimestring;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  currenttimestring :=
   integertozstring(h,2)+':'+integertozstring(m,2)+':'+integertozstring(s,2);
end;

function currenttimedigits;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  currenttimedigits :=
   integertozstring(h,2)+integertozstring(m,2)+integertozstring(s,2);
end;

function dow;

var
  y,m,d,realdow: word;

begin
  getdate(y,m,d,realdow);
  dow := realdow;
end;

function extcdow;

var
  result: string;

begin
  result := 'Sunday';
  if thedow=1 then result := 'Monday';
  if thedow=2 then result := 'Tuesday';
  if thedow=3 then result := 'Wednesday';
  if thedow=4 then result := 'Thursday';
  if thedow=5 then result := 'Friday';
  if thedow=6 then result := 'Saturday';

  extcdow := result;
end;

function cdow;

begin
  cdow := extcdow(dow);
end;

function dayofmonth;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  dayofmonth := d;
end;

function month;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  month := m;
end;

function extmonthname;

var
  result: string;

begin
  result := 'January';
  if themonth=2  then result := 'February';
  if themonth=3  then result := 'March';
  if themonth=4  then result := 'April';
  if themonth=5  then result := 'May';
  if themonth=6  then result := 'June';
  if themonth=7  then result := 'July';
  if themonth=8  then result := 'August';
  if themonth=9  then result := 'September';
  if themonth=10 then result := 'October';
  if themonth=11 then result := 'November';
  if themonth=12 then result := 'December';

  extmonthname := result;
end;

function monthname;

begin
  monthname := extmonthname(month);
end;

function year;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  year := y;
end;

function dayofweek;

var
  result: word;

  century: word;
  year: word;
  month: word;

begin
{

from an old sci.math FAQ

15Q:  Is there a formula to determine the day of the week, given
    the month, day and year?

A:  Here is the standard method.

[...]

    Another formula is:

    W == k + [2.6m - 0.2] - 2C + Y + [Y/4] + [C/4]     mod 7
       where [] denotes the integer floor function (round down),
       k is day (1 to 31)
       m is month (1 = March, ..., 10 = December, 11 = Jan, 12 = Feb)
                     Treat Jan & Feb as months of the preceding year
       C is century ( 1987 has C = 19)
       Y is year    ( 1987 has Y = 87 except Y = 86 for jan & feb)
       W is week day (0 = Sunday, ..., 6 = Saturday)

    This formula is good for the Gregorian calendar
    (introduced 1582 in parts of Europe, adopted in 1752 in Great Britain
    and its colonies, and on various dates in other countries).

    It handles century & 400 year corrections, but there is still a
    3 day / 10,000 year error which the Gregorian calendar does not take.
    into account.  At some time such a correction will have to be
    done but your software will probably not last that long :-)   !


    References:

    Winning Ways  by Conway, Guy, Berlekamp is supposed to have it.

    Martin Gardner in "Mathematical Carnival".

    Michael Keith and Tom Craver, "The Ultimate Perpetual Calendar?",
    Journal of Recreational Mathematics, 22:4, pp. 280-282, 1990.

    K. Rosen, "Elementary Number Theory",  p. 156.

}

  year := y;
  month := m;

  if month<3 then
    begin
      inc(month,12);
      dec(year);
    end;

  dec(month,2);

  century := (year div 100);
  year := year mod 100;

  result := d+trunc(2.6*month-0.2)-2*century+year+year div 4+century div 4;

{handle negative mods}
  result := result mod 7;
  if result<0 then
    result := 7+result;

  dayofweek := result;
end;

function ymdtostring;

begin
  ymdtostring := wordtozstring(year,2)+'-'+
   wordtozstring(month,2)+'-'+wordtozstring(day,2);
end;

function timetostring;

var
  result: string;
  dt: datetime;

begin
  unpacktime(atime,dt);
  result :=
       wordtozstring(dt.year,4)+
   '/'+wordtozstring(dt.month,2)+
   '/'+wordtozstring(dt.day,2)+
   '_'+wordtozstring(dt.hour,2)+
   ':'+wordtozstring(dt.min,2)+
   ':'+wordtozstring(dt.sec,2);
  timetostring := result;
end;

function dateformatted;

const
  wstrings='SMTWRFA';

var
  result: string;
  tempformat: string;
  formatchars: integer;
  dow: integer;

begin
  result := '';
  dow := -1; {unknown}

  if (dateformat<>'') and (dateformat<>'-') then
    begin
      tempformat := dateformat;
      while tempformat<>'' do
        begin
          if copy(tempformat,1,1)='s' then
            begin
              result := result+' ';
              formatchars := 1;
            end
          else if copy(tempformat,1,3)='www' then
            begin
              if dow<0 then
                dow := dayofweek(y,m,d);
              result := result+copy(extcdow(dow),1,3);
              formatchars := 3;
            end
          else if copy(tempformat,1,2)='ww' then
            begin
              if dow<0 then
                dow := dayofweek(y,m,d);
              result := result+copy(extcdow(dow),1,2);
              formatchars := 2;
            end
          else if copy(tempformat,1,1)='w' then
            begin
              if dow<0 then
                dow := dayofweek(y,m,d);
              result := result+copy(wstrings,1+dow,1);
              formatchars := 1;
            end
          else if copy(tempformat,1,4)='yyyy' then
            begin
              result := result+wordtozstring(y,4);
              formatchars := 4;
            end
          else if copy(tempformat,1,2)='yy' then
            begin
              result := result+wordtozstring(y mod 100,2);
              formatchars := 2;
            end
          else if copy(tempformat,1,3)='mmm' then
            begin
              result := result+copy(extmonthname(m),1,3);
              formatchars := 3;
            end
          else if copy(tempformat,1,2)='mm' then
            begin
              result := result+wordtozstring(m,2);
              formatchars := 2;
            end
          else if copy(tempformat,1,2)='dd' then
            begin
              result := result+wordtozstring(d,2);
              formatchars := 2;
            end
          else
            begin
              result := result+copy(tempformat,1,1);
              formatchars := 1;
            end;

          tempformat := lchop(tempformat,formatchars);
        end;
    end;

  dateformatted := result;
end;

function currentdatestring;

var
  year, month, day, dayofweek: word;

begin
  getdate(year,month,day,dayofweek);
  currentdatestring := ymdtostring(year,month,day);
end;

function getenv;

var
  result: string;

  i: integer;
  envseg: word;
  envread: integer;
  firstb: byte;
  thisb: byte;
  varname: string;
  vardata: string;
  done: boolean;

begin
  result := '';

  envseg := memw[prefixseg:$2c];

  envread := 0;
  repeat
    firstb := mem[envseg:envread];

    if firstb>0 then
      begin
        varname := '';

        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb<>ord('=') then
            varname := varname+chr(thisb);
        until thisb=ord('=');

        vardata := '';

        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb>0 then
            vardata := vardata+chr(thisb);
        until thisb=0;

        done := (varname=s);
        if done then
          result := vardata;
    end;
  until (firstb=0) or done;

  getenv := result;
end;

function numoccur;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(s) do
    if s[i]=c then
      inc(result);

  numoccur := result;
end;

function hasany;

begin
  hasany := (numoccur(c,s)<>0);
end;

function hasno;

begin
  hasno := not hasany(c,s);
end;

function unquote;

begin
  if (s[1]='"') and (s[length(s)]='"') then
    unquote := copy(s,2,length(s)-2)
  else
    unquote := s;
end;

function crepl;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(result) do
    if result[i]=cold then
      result[i] := cnew;

  crepl := result;
end;

function unslash;

begin
  unslash := crepl(s,'/','\');
end;

function unbackslash;

begin
  if s='' then
    unbackslash := s
  else if copy(s,length(s),1)='\' then
    unbackslash := copy(s,1,length(s)-1)
  else
    unbackslash := s;
end;

function ununderscore;

begin
  ununderscore := crepl(s,'_',space);
end;

function uncomma;

begin
  uncomma := crepl(s,comma,space);
end;

{}{}{}{} { srepl('aa','a','') doesn't work :-( }

function srepl;

var
  result: string;
  at: integer;

begin
  result := s;

  if (sold<>'') and (sold<>snew) then
    begin
      at := 0;
      while at<=length(result)-length(sold) do
        begin
          inc(at);
          if result[at]=sold[1] then
            if copy(result,at,length(sold))=sold then
              begin
                if sold=result then
                  result := snew
                else if at=1 then
                  result := snew+copy(result,length(sold)+1,255)
                else if at=length(result)-length(sold)+1 then
                  result := copy(result,1,at-1)+snew
                else
                  result :=
                   copy(result,1,at-1)+snew+copy(result,at+length(sold),255);
            end;
        end;
    end;

  srepl := result;
end;

function srepli; {case-insensitive}

var
  result: string;
  at: integer;
  uppersold: string;

begin
  result := s;
  uppersold := upper(sold);

  if (sold<>'') and (uppersold<>upper(snew)) then
    begin
      at := 0;
      while at<=length(result)-length(sold) do
        begin
          inc(at);
          if upcase(result[at])=uppersold[1] then
            if upper(copy(result,at,length(sold)))=uppersold then
              begin
                if uppersold=upper(result) then
                  result := snew
                else if at=1 then
                  result := snew+copy(result,length(sold)+1,255)
                else if at=length(result)-length(sold)+1 then
                  result := copy(result,1,at-1)+snew
                else
                  result :=
                   copy(result,1,at-1)+snew+copy(result,at+length(sold),255);
            end;
        end;
    end;

  srepli := result;
end;

function sreplmulti;

var
  result: string;
  firstpass: string;

begin
  firstpass := srepl(s,sold,snew);
  result := firstpass;

  if firstpass<>s then
    result := srepl(firstpass,sold,snew);

  if result<>firstpass then
    result := srepl(result,sold,snew);

  sreplmulti := result;
end;

function unspace;

var
  result: string;
  i: integer;

begin
  if (numoccur(' ',s)=0) and (numoccur(tab,s)=0) then
    result := s
  else
    begin
      result := '';
      for i := 1 to length(s) do
        if (s[i]<>' ') and (s[i]<>tab) then
          result := result+s[i];
    end;

  unspace := result;
end;

function atow;

var
  result: word;
  code: word;

begin
  val(s,result,code);
  atow := result;
end;

function atoi;

var
  result: integer;
  code: word;

begin
  val(s,result,code);
  atoi := result;
end;

function atol;

var
  result: longint;
  code: word;

begin
  val(s,result,code);
  atol := result;
end;

function wtoa;

begin
  wtoa := wordtozstring(w,0);
end;

function itoa;

begin
  itoa := integertozstring(i,0);
end;

function ltoa;

begin
  ltoa := longtozstring(l,0);
end;

function lowcase; {similar to the supplied upcase}

begin
  if (c>='A') and (c<='Z') then
    lowcase := chr(ord(c)-ord('A')+ord('a'))
  else
    lowcase := c;
end;

function upper;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(s) do
    result[i] := upcase(result[i]);

  upper := result;
end;

function lower;

var
  result: string;
  i: integer;

begin
  result := s;

  for i := 1 to length(s) do
    result[i] := lowcase(result[i]);

  lower := result;
end;

function proper;

var
  result: string;
  i: integer;
  shouldup: boolean;

begin
  result := s;

  shouldup := true;

  for i := 1 to length(s) do
    begin
      if shouldup then
        result[i] := upcase(result[i])
      else
        result[i] := lowcase(result[i]);
      shouldup := not isalpha(result[i]);
    end;

  proper := result;
end;

function ltrim;

var
  result: string;

begin
  result := s;

  while ((result[1]=' ') or (result[1]=tab)) and (length(result)>0) do
    result := copy(result,2,255);

  ltrim := result;
end;

function trim;

var
  result: string;

begin
  result := s;

  while ((result[length(result)]=' ') or (result[length(result)]=tab)) and
   (length(result)>0) do
    result := copy(result,1,length(result)-1);

  trim := result;
end;

function right;

begin
  right := copy(s,max(1,length(s)-i+1),i);
end;

function getfirstw;

var
  result: string;
  spaceat: integer;
  tabat: integer;

begin
  result := trim(ltrim(s));
  spaceat := pos(' ',result);
  tabat := pos(tab,result);

  if tabat>0 then
    if (spaceat>0) and (tabat>spaceat) then
      result := copy(result,1,spaceat-1)
    else
      result := copy(result,1,tabat-1)
  else
    if spaceat>0 then
      result := copy(result,1,spaceat-1);

  getfirstw := result;
end;

function chopfirstw;

var
  result: string;

begin
  s := trim(ltrim(s));
  result := getfirstw(s);
  s := ltrim(copy(s,length(result)+1,255));

  chopfirstw := result;
end;

function getquoted;

var
  result: string;

begin
  result := '';

  if copy(s,1,1)='"' then
    begin
      result := copy(s,2,255);
      if pos('"',result)=0 then
        result := getfirstw(result)
      else
        result := copy(result,1,pos('"',result)-1);
    end
  else
    result := getfirstw(s);

  getquoted := result;
end;

function randomletter;

begin
  if random(2)=0 then
    randomletter := chr(ord('a')+random(26))
  else
    randomletter := chr(ord('A')+random(26));
end;

function randomdigit;

begin
  randomdigit := chr(ord('0')+random(10));
end;

function getfromaddr;

var
  result: string;
  at: integer;

begin
  at := rpos('<',from);  {used to be pos, but that didn't work on illegals}

  if at>0 then {Full Name <address>}
    result := copy(from,at+1,length(from)-at-1)
  else
    begin
      at := pos(' ',from);
      if at>0 then {address (Full Name)}
        result := copy(from,1,at-1)
      else {address}
        result := from;
    end;

  getfromaddr := result;
end;

{be careful with address like

  "Some (Happy) User" <[e-mail]>

- need to grab the right parts right}

function getfromname;

var
  result: string;
  at: integer;

begin
  result := '';

  if copy(from,length(from),1)='>' then
    begin
      at := rpos('<',from);  {not pos to avoid breaking illegal headers}
      if at>1 then
        result := copy(from,1,at-2);
    end;

  if result='' then
    begin
      at := pos('(',from);
      if at>0 then
        result := copy(from,at+1,length(from)-at-1)
      else
        begin
          at := rpos('<',from);
          if at>1 then
            result := copy(from,1,at-2);
        end;
    end;

  getfromname := unquote(result);
end;

{changed from `chop' to `lchop' since perl's chop chops from the right}
function lchop;

var
  result: string;

begin
  lchop := copy(s,i+1,255);
end;

function nore;

begin

{should always be 4 and 'Re: ', but uppercase and ltrim to deal with others}

  if upper(copy(s,1,3))='RE:' then
    nore := ltrim(lchop(s,3))
  else
    nore := s;
end;

function monthstringtointeger;

var
  result: integer;
  lowermonthstr: string;

begin
  result := 12;

  lowermonthstr := lower(monthstr);

  if lowermonthstr='jan' then result := 1
  else if lowermonthstr='feb' then result := 2
  else if lowermonthstr='mar' then result := 3
  else if lowermonthstr='apr' then result := 4
  else if lowermonthstr='may' then result := 5
  else if lowermonthstr='jun' then result := 6
  else if lowermonthstr='jul' then result := 7
  else if lowermonthstr='aug' then result := 8
  else if lowermonthstr='sep' then result := 9
  else if lowermonthstr='oct' then result := 10
  else if lowermonthstr='nov' then result := 11;

  monthstringtointeger := result;
end;

function isalpha;

begin
  isalpha := ( (upcase(c)>='A') and (upcase(c)<='Z') );
end;

function isdigit;

begin
  isdigit := (c>='0') and (c<='9');
end;

function isalnum;

begin
  isalnum := isalpha(c) or isdigit(c);
end;

function isidentchar;

begin
  isidentchar := isalpha(c) or isdigit(c) or (c='_');
end;

function islower;

begin
  islower := (c>='a') and (c<='z');
end;

function isspace;

begin
  isspace := (c=' ') or (c=tab) or (c=cr) or (c=lf);
end;

function snatchint;

var
  intsofar: integer;

begin
  intsofar := 0;

  while (length(s)>0) and not isdigit(s[1]) do
    s := lchop(s,1);

  while (length(s)>0) and isdigit(s[1]) do
    begin
      intsofar := 10*intsofar+ord(s[1])-ord('0');
      s := lchop(s,1);
    end;

  snatchint := intsofar;
end;

function isdev;

{isdev is not perfect -- it always stops on the 128th iteration, just in case}

var
  result: boolean;
  offs: word;
  segm: word;
  oldsegm: word;
  foundnul: boolean;
  basename: string;
  i: integer;
  iterations: integer;

begin
  result := false;

  iterations := 0;

  segm := 0;
  offs := $400;

  basename := upper(unslash(s));

{handle LPT1: case}
  if copy(basename,length(basename),1)=':' then
    basename := copy(basename,1,length(basename)-1);

{strip disk and path designators}
  while pos(':',basename)<>0 do
    basename := copy(basename,pos(':',basename)+1,255);
  while pos('\',basename)<>0 do
    basename := copy(basename,pos('\',basename)+1,255);

{strip anything after the first period}
  if pos('.',basename)<>0 then
    basename := copy(basename,1,pos('.',basename)-1);

{NUL is supposed to be guaranteed the first in the chain}
  foundnul := false;
  while (not foundnul) and (offs>0) do
    begin

{offs is always in range 1..400 here}

      if (mem[segm:offs]=ord('N')) and
       (mem[segm:offs+1]=ord('U')) and
       (mem[segm:offs+2]=ord('L')) and
       (mem[segm:offs+3]=ord(' ')) and
       (mem[segm:offs+4]=ord(' ')) and
       (mem[segm:offs+5]=ord(' ')) and
       (mem[segm:offs+6]=ord(' ')) and
       (mem[segm:offs+7]=ord(' ')) then
        begin

          if offs<6 then
            begin
              writeln('!! error in isdev: offs<6, first loop -- see source');
              halt(1);
            end;

{$ifdef devverbose}
          writeln('found NUL at ',offs);
          writeln('attrib=',memw[segm:offs-6]);
{$endif}

          if memw[segm:offs-6]=$8004 then
            begin

{$ifdef devverbose}
              writeln('looks like the real NUL to me!');
{$endif}

              foundnul := true;
            end;
        end;

      if not foundnul then
        inc(offs);
    end;

  if foundnul then
    begin

      while length(basename)<8 do
        basename := basename+' ';

      if offs<10 then
        begin
          inc(offs,32);
          dec(segm,2);
        end;

      if offs>65000 then
        begin
          dec(offs,32);
          inc(segm,2);
        end;

      while not result and
       (meml[segm:offs-10]<>$ffffffff) and
       (iterations<128) do

        begin
          inc(iterations);

          result := true;
          for i := 0 to 7 do
            result := result and (chr(mem[segm:offs+i])=basename[1+i]);

{$ifdef devverbose}
          writeln('name of device=',
           chr(mem[segm:offs]),
           chr(mem[segm:offs+1]),
           chr(mem[segm:offs+2]),
           chr(mem[segm:offs+3]),
           chr(mem[segm:offs+4]),
           chr(mem[segm:offs+5]),
           chr(mem[segm:offs+6]),
           chr(mem[segm:offs+7]),
           '.');

          writeln('new position: ',memw[segm:offs-10],':',memw[segm:offs-8]);
{$endif}

          oldsegm := segm;
          segm := memw[oldsegm:offs-8];
          offs := memw[oldsegm:offs-10];

          if offs<10 then
            begin
              inc(offs,32);
              dec(segm,2);
            end;

          if offs>65000 then
            begin
              dec(offs,32);
              inc(segm,2);
            end;

          offs := offs+10;

        end;

    end;

  if iterations>=128 then
    writeln(
     '(don''t worry!) isdev could not check for a device,',
     ' continuing anyway');

  isdev := result;
end;

{$ifdef testfn}
program testfn;  {tests what characters are legal in filenames}

var
  i: integer;
  fn: string;
  f: text;

begin
  for i := 1 to 255 do
    begin
      fn := '';
      fn := fn+chr(((i        ) div 100)+ord('0'));
      fn := fn+chr(((i mod 100) div  10)+ord('0'));
      fn := fn+chr(((i mod  10)        )+ord('0'));
      fn := fn+'_';
      fn := fn+chr(i);
      assign(f,fn);
{$I-}
      rewrite(f);
{$I+}
      if ioresult=0 then
        close(f);

      writeln(i);
    end;
end.
{$endif}

function illegalfn;  {only works on unslash()ed strings}

var
  result: boolean;
  i: integer;
  components: string;
  acomponent: string;

begin

{if colon, must be col 2 -- don't use things like lpt1: or com1: }

  result := false;

  if numoccur(':',fn)>1 then              { can't have two colons }
    result := true
  else if (pos(':',fn)<>0) and (pos(':',fn)<>2) then
    result := true;

  for i := 1 to length(fn) do
    if not result then
      if not (fn[i] in alwayslegalchars) then
        if not (fn[i] in sometimeslegalchars) then
          result := true;

  if not result then
    begin
      components := fn;
      if pos(':',components)<>0 then
        components := copy(components,pos(':',components)+1,255);

      components := trim(ltrim(crepl(components,'\',' ')));
      while components<>'' do
        begin
          acomponent := chopfirstw(components);
          for i := 1 to length(acomponent) do
            if numoccur('.',acomponent)>1 then
              result := true
            else if acomponent[1]='.' then
              result := true;
        end;
    end;

  illegalfn := result;
end;

function suspiciousfn;

{note that unslash must have already been used!}

var
  result: boolean;
  upfn: string;

begin
  result := false;
  upfn := upper(fn);

  if illegalfn(upfn) then
    result := true
  else if numoccur(':',upfn)>0 then
    result := true
  else if numoccur('\',upfn)>0 then
    result := true
  else {common devices just in case isdev misses them}
    if (upfn='CON') or
     (upfn='PRN') or
     (upfn='AUX') or
     (upfn='NUL') or
     (upfn='LPT1') or
     (upfn='LPT2') or
     (upfn='LPT3') or
     (upfn='COM1') or
     (upfn='COM2') or
     (upfn='COM3') or
     (upfn='COM4') or
     (upfn='CLOCK$') then
      result := true
  else {isdev uses icky memory peeking, so don't run it if you can avoid it}
    if isdev(upfn) then
      result := true;

  suspiciousfn := result;
end;

function highestartin;

var
  result: longint;
  fileinfo: searchrec;

begin
  result := 0;

  findfirst(withbackslash(groupdir)+'*',archive,fileinfo);
  while doserror=0 do
    begin
      result := lmax(result,atol(fileinfo.name));
      findnext(fileinfo);
    end;

  highestartin := result;
end;

function getuniqfile;

var
  result: string;
  mangledgroupdir: string;

begin
  mangledgroupdir := groupdir;

{}{need to keep each directory under 8 chars}

{avoid problems when keeping outbox copy for mail to [e-mail] etc.}

  if isdev(mangledgroupdir) then
    begin
      mangledgroupdir := groupdir+'_';

{some device names are 8 chars, and just adding a `_' won't help}

      if isdev(mangledgroupdir) then
        mangledgroupdir := copy(groupdir,1,length(groupdir)-1)+'_';
    end;

  getuniqfile := withbackslash(mangledgroupdir)+
   ltoa(highestartin(mangledgroupdir)+1);
end;

function getuniqfext;

var
  result: word;
  fileinfo: searchrec;
  filefound: string;
  mangledbasename: string;

begin
  result := 0;
  mangledbasename := basename;

{}{need to keep each directory under 8 chars}

{avoid problems when keeping outbox copy for mail to [e-mail] etc.}

  if isdev(mangledbasename) then
    begin
      mangledbasename := basename+'_';

{some device names are 8 chars, and just adding a `_' won't help}

      if isdev(mangledbasename) then
        mangledbasename := copy(basename,1,length(basename)-1)+'_';
    end;

  findfirst(mangledbasename+'.*',archive,fileinfo);
  while doserror=0 do
    begin
      filefound := fileinfo.name;
      while pos('.',filefound)>0 do
        filefound := copy(filefound,pos('.',filefound)+1,255);
      result := max(result,atoi(filefound));
      findnext(fileinfo);
    end;

  getuniqfext := mangledbasename+'.'+wtoa(result+1);
end;

function expand;

var
  work: string;
  i,j: integer;

begin
  if pos(tab,str)=0 then
    expand := str
  else
    begin
      work := '';
      for i := 1 to length(str) do
        if length(work)<240 then
          if str[i]=tab then
            for j := 1 to 8-(length(work) and 7) do
              work := work+' '
          else
            work := work+str[i];
      expand := work;
    end;
end;

function rot13;

var
  result: string;
  upc: char;
  i: integer;

begin
  result := s;

  for i := 1 to length(result) do
    begin
      upc := upcase(result[i]);
      if (upc>='A') and (upc<='M') then
        result[i] := chr(ord(result[i])+13)
      else if (upc>='N') and (upc<='Z') then
        result[i] := chr(ord(result[i])-13);
    end;

  rot13 := result;
end;

function indir;

var
  fileinfo: searchrec;

begin
  findfirst(withbackslash(dir)+filespec,archive,fileinfo);
  indir := (doserror=0);
end;

function default;

begin
  if possiblyemptystr='' then
    default := defaultstr
  else
    default := possiblyemptystr;
end;

function rpos;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(whole)-length(sub)+1 do
    if copy(whole,i,length(sub))=sub then
      result := i;

  rpos := result;
end;

function rposc;

var
  result: integer;
  i: integer;

begin
  result := 0;

  for i := 1 to length(s) do
    if s[i]=c then
      result := i;

  rposc := result;
end;

function fexists;

var
  result: boolean;
  f: text;

begin
  result := false;

  assign(f,fn);
{$I-}
  reset(f);
{$I+}
  if ioresult=0 then
    begin
      close(f);
      result := true;
    end;

  fexists := result;
end;

function dexists;

var
  result: boolean;
  newdn: string;
  fileinfo: searchrec;

begin
  result := false;

  newdn := unslash(dn);
  if right(newdn,1)='\' then
    newdn := newdn+'.';
  if right(newdn,1)=':' then
    newdn := newdn+'.';

  findfirst(newdn,directory,fileinfo);

  if doserror=0 then
    if (fileinfo.attr and directory)<>0 then
      result := true;

  dexists := result;
end;

function getfntime;

var
  result: longint;
  f: text;

begin
  result := 0;

  assign(f,fn);
{$I-}
  reset(f);
{$I+}
  if ioresult=0 then
    begin
      getftime(f,result);
      close(f);
    end;

  getfntime := result;
end;

{size from a filename, not from a file handle}
function getfnsize;

var
  result: longint;
  f: file;

begin
  result := -1;

  assign(f,fn);
{$I-}
  reset(f,1);
{$I+}
  if ioresult=0 then
    begin
      result := filesize(f);
      close(f);
    end;

  getfnsize := result;
end;

function withbackslash;  {nonempty gets terminated with backslash}

var
  result: string;

begin
  result := s;
  if result<>'' then
    if result[length(result)]<>'\' then
      result := result+'\';

  withbackslash := result;
end;

function nobeep;

var
  result: string;

begin
  result := crepl(s,chr(7),'^');
  nobeep := result;
end;

function nonastychar;

var
  result: string;

begin
  result := crepl(s,chr(7),'^');
  result := crepl(result,chr(27),'^');
  nonastychar := result;
end;

function gettag;

var
  result: string;

begin
  result := '';

  if pos(tag,s)<>0 then
    begin
      result := copy(s,pos(tag,s)+length(tag),255);
      result := getquoted(result);
    end;

  gettag := result;
end;

function hexchar;

begin
  if i<10 then
    hexchar := chr(ord('0')+i)
  else
    hexchar := chr(ord('a')+i-10);
end;

function partialmatch;

var
  result: boolean;

begin
  result := false;

  if (length(cmd)<=length(template)) and (length(cmd)>=length(minimum)) then
    if copy(template,1,length(cmd))=cmd then
      result := true;

  partialmatch := result;
end;

function doserrorno;  {prevents units having to include dos for 1 call}

begin
  doserrorno := doserror;
end;

function wordwith;

var
  result: string;
  temps: string;

begin
  result := '';
  temps := s;

  while (result='') and (temps<>'') do
    begin
      result := chopfirstw(temps);
      if pos(c,result)=0 then
        result := '';
    end;

  wordwith := result;
end;

function isasciifile;

const
  checkedsize=1024;

var
  result: boolean;

{$ifdef veryslowisasciifile}
  inf: file of byte;
{$endif}
  inf: file;
  whichbyte: integer;
  onebyte: byte;
{$ifdef veryslowisasciifile}
  stillsearching: boolean;
{$endif}
  buffer: array[1..checkedsize] of byte;
  numread: word;

begin
  result := true;

{$ifdef veryslowisasciifile}
  assign(inf,fn);
{$I-}
  reset(inf);
{$I+}
{$endif}

  assign(inf,fn);
{$I-}
  reset(inf,1);
{$I+}

  if ioresult<>0 then
    result := false
  else
    begin
{$ifdef veryslowisasciifile}
      stillsearching := true;

      for whichbyte := 1 to checkedsize do
        if stillsearching then
          begin
            if eof(inf) then
              stillsearching := false
            else
              begin
                read(inf,onebyte);
                if not
                (
                 (onebyte=9)
                or
                 (onebyte=10)
                or
                 (onebyte=13)
                or
                 ( (onebyte>=32) and (onebyte<=126) )
                )
                  then
                    begin
                      result := false;
                      stillsearching := false;
                    end;
              end;
          end;
      close(inf);
{$endif}

      blockread(inf,buffer,checkedsize,numread);
      close(inf);

      for whichbyte := 1 to numread do
        if result then
          begin
            onebyte := buffer[whichbyte];
            if not
            (
             (onebyte=9)
            or
             (onebyte=10)
            or
             (onebyte=13)
            or
             ( (onebyte>=32) and (onebyte<=126) )
            )
              then
                result := false;
          end;

    end;

  isasciifile := result;
end;

function nthfield;

var
  result: string;
  chopfieldcount: integer;
  delimpos: integer;
  tempstring: string;

begin
  tempstring := astring;
  for chopfieldcount := 1 to n-1 do
    tempstring := lchop(tempstring,pos(delim,tempstring));

  delimpos := pos(delim,tempstring);
  if delimpos=0 then
    result := ''
  else
    result := copy(tempstring,1,delimpos-1);

  nthfield := result;
end;

function isinlist;

begin
  isinlist := pos(delim+upper(astring)+delim,delim+upper(alist)+delim)<>0;
end;

function sornos;

begin
  if n=1 then sornos := '' else sornos := 's';
end;

{}{}{}{} { this is NOT full regex at this time }

function regexintext;

var
  result: boolean;
  mangledaregex: string;
  onesearch: string;
  foundend: boolean;
  escaped: boolean;
  onech: char;

begin
  result := false;

  if pos('|',aregex)=0 then
    result := pos(aregex,awholetext)<>0
  else
    begin
      mangledaregex := aregex;
      while (mangledaregex<>'') and not result do
        begin
          onesearch := '';
          escaped := false;

          foundend := false;
          while not foundend do
            begin
              if mangledaregex='' then
                foundend := true
              else
                begin
                  onech := mangledaregex[1];
                  mangledaregex := lchop(mangledaregex,1);
                  if escaped then
                    begin
                      escaped := false;
                      onesearch := onesearch+onech;
                    end
                  else if onech='\' then
                    begin
                      escaped := true;
                    end
                  else
                    begin
                      escaped := false;
                      if onech='|' then
                        foundend := true
                      else
                        onesearch := onesearch+onech;
                    end;
                end;
            end;

          result := pos(onesearch,awholetext)<>0;

        end;
    end;

  regexintext := result;
end;

function enclosedin;

begin
  if length(astring)<2 then
    enclosedin := false
  else
    enclosedin := (astring[1]=lchar) and (astring[length(astring)]=rchar);
end;

function isaleapyear;

begin
  if (ayear mod 400)=0 then
    isaleapyear := true
  else if (ayear mod 100)=0 then
    isaleapyear := false
  else if (ayear mod 4)=0 then
    isaleapyear := true
  else
    isaleapyear := false;
end;

function daysinyear;

begin
  if isaleapyear(ayear) then
    daysinyear := 366
  else
    daysinyear := 365;
end;

function daysinyearmonth;

begin
  case amonth of
     1: daysinyearmonth := 31;
     2: if isaleapyear(ayear) then
          daysinyearmonth := 29
        else
          daysinyearmonth := 28;
     3: daysinyearmonth := 31;
     4: daysinyearmonth := 30;
     5: daysinyearmonth := 31;
     6: daysinyearmonth := 30;
     7: daysinyearmonth := 31;
     8: daysinyearmonth := 31;
     9: daysinyearmonth := 30;
    10: daysinyearmonth := 31;
    11: daysinyearmonth := 30;
    12: daysinyearmonth := 31;
  end;
end;

function dayspast1970;

var
  result: longint;
  ayear: integer;
  amonth: integer;

begin
  result := 0;

  if y>=1970 then
    begin
      for ayear := 1970 to y-1 do
        inc(result,daysinyear(ayear));

      for amonth := 1 to m-1 do
        inc(result,daysinyearmonth(ayear,amonth));

      inc(result,d-1);
    end;

  dayspast1970 := result;
end;





{weird code follows}

{$ifdef VER40}
function dosversion;

var
  regs: registers;

begin
  regs.ah := $30;
  msdos(regs);
  dosversion := regs.ax;
end;
{$endif}

{$ifdef floatingpoint}
function ator;

var
  r: real;
  code: word;

begin
  val(s,r,code);
  ator := r;
end;

function rtoa;

var
  a: string;

begin
  str(r,a);
  rtoa := a;
end;

function rwptoa;

var
  a: string;

begin
  str(r:width:precision,a);
  rwptoa := a;
end;

function rtonicea;

var
  a: string;

begin
  str(r:0:10,a);
  while (length(a)>1) and (right(a,1)='0') do
    a := copy(a,1,length(a)-1);
  if right(a,1)='.' then
    a := copy(a,1,length(a)-1);
  rtonicea := a;
end;

{$endif}

end.